home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / OldSrc / CH10 / SRC / EXTRUDE.FRM (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1996-05-02  |  19.5 KB  |  638 lines

  1. VERSION 4.00
  2. Begin VB.Form ExtrudeForm 
  3.    Appearance      =   0  'Flat
  4.    BackColor       =   &H00C0C0C0&
  5.    Caption         =   "Extrude"
  6.    ClientHeight    =   5700
  7.    ClientLeft      =   690
  8.    ClientTop       =   900
  9.    ClientWidth     =   7830
  10.    BeginProperty Font 
  11.       name            =   "MS Sans Serif"
  12.       charset         =   1
  13.       weight          =   700
  14.       size            =   8.25
  15.       underline       =   0   'False
  16.       italic          =   0   'False
  17.       strikethrough   =   0   'False
  18.    EndProperty
  19.    ForeColor       =   &H80000008&
  20.    Height          =   6390
  21.    KeyPreview      =   -1  'True
  22.    Left            =   630
  23.    LinkTopic       =   "Form1"
  24.    ScaleHeight     =   380
  25.    ScaleMode       =   3  'Pixel
  26.    ScaleWidth      =   522
  27.    Top             =   270
  28.    Width           =   7950
  29.    Begin VB.CommandButton CmdExtrude 
  30.       Caption         =   "Extrude"
  31.       Height          =   495
  32.       Left            =   720
  33.       TabIndex        =   11
  34.       Top             =   5040
  35.       Width           =   855
  36.    End
  37.    Begin VB.Frame Frame2 
  38.       Caption         =   "Curve"
  39.       Height          =   2415
  40.       Left            =   0
  41.       TabIndex        =   10
  42.       Top             =   0
  43.       Width           =   2295
  44.       Begin VB.OptionButton CurveChoice 
  45.          Caption         =   "Sine Wave"
  46.          Height          =   255
  47.          Index           =   5
  48.          Left            =   120
  49.          TabIndex        =   22
  50.          Top             =   2040
  51.          Width           =   2055
  52.       End
  53.       Begin VB.OptionButton CurveChoice 
  54.          Caption         =   "Small Circle"
  55.          Height          =   255
  56.          Index           =   4
  57.          Left            =   120
  58.          TabIndex        =   21
  59.          Top             =   1680
  60.          Width           =   2055
  61.       End
  62.       Begin VB.OptionButton CurveChoice 
  63.          Caption         =   "Circle"
  64.          Height          =   255
  65.          Index           =   3
  66.          Left            =   120
  67.          TabIndex        =   20
  68.          Top             =   1320
  69.          Width           =   2055
  70.       End
  71.       Begin VB.OptionButton CurveChoice 
  72.          Caption         =   "Semicircle"
  73.          Height          =   255
  74.          Index           =   2
  75.          Left            =   120
  76.          TabIndex        =   19
  77.          Top             =   960
  78.          Width           =   2055
  79.       End
  80.       Begin VB.OptionButton CurveChoice 
  81.          Caption         =   "Rectangle"
  82.          Height          =   255
  83.          Index           =   1
  84.          Left            =   120
  85.          TabIndex        =   18
  86.          Top             =   600
  87.          Width           =   2055
  88.       End
  89.       Begin VB.OptionButton CurveChoice 
  90.          Caption         =   "Square"
  91.          Height          =   255
  92.          Index           =   0
  93.          Left            =   120
  94.          TabIndex        =   12
  95.          Top             =   240
  96.          Value           =   -1  'True
  97.          Width           =   2055
  98.       End
  99.    End
  100.    Begin VB.Frame Frame1 
  101.       Caption         =   "Path"
  102.       Height          =   2415
  103.       Left            =   0
  104.       TabIndex        =   8
  105.       Top             =   2520
  106.       Width           =   2295
  107.       Begin VB.OptionButton PathChoice 
  108.          Caption         =   "Circle"
  109.          Height          =   255
  110.          Index           =   5
  111.          Left            =   120
  112.          TabIndex        =   17
  113.          Top             =   2040
  114.          Width           =   2055
  115.       End
  116.       Begin VB.OptionButton PathChoice 
  117.          Caption         =   "Semicircle"
  118.          Height          =   255
  119.          Index           =   4
  120.          Left            =   120
  121.          TabIndex        =   16
  122.          Top             =   1680
  123.          Width           =   2055
  124.       End
  125.       Begin VB.OptionButton PathChoice 
  126.          Caption         =   "Helix"
  127.          Height          =   255
  128.          Index           =   3
  129.          Left            =   120
  130.          TabIndex        =   15
  131.          Top             =   1320
  132.          Width           =   2055
  133.       End
  134.       Begin VB.OptionButton PathChoice 
  135.          Caption         =   "Wavy Line"
  136.          Height          =   255
  137.          Index           =   2
  138.          Left            =   120
  139.          TabIndex        =   14
  140.          Top             =   960
  141.          Width           =   2055
  142.       End
  143.       Begin VB.OptionButton PathChoice 
  144.          Caption         =   "Angled Line"
  145.          Height          =   255
  146.          Index           =   1
  147.          Left            =   120
  148.          TabIndex        =   13
  149.          Top             =   600
  150.          Width           =   2055
  151.       End
  152.       Begin VB.OptionButton PathChoice 
  153.          Caption         =   "Vertical Line"
  154.          Height          =   255
  155.          Index           =   0
  156.          Left            =   120
  157.          TabIndex        =   9
  158.          Top             =   240
  159.          Value           =   -1  'True
  160.          Width           =   2055
  161.       End
  162.    End
  163.    Begin VB.CheckBox ShowAxesCheck 
  164.       Caption         =   "Show Axes"
  165.       Height          =   255
  166.       Left            =   2400
  167.       TabIndex        =   7
  168.       Top             =   5400
  169.       Width           =   1335
  170.    End
  171.    Begin VB.TextBox PhiText 
  172.       Height          =   285
  173.       Left            =   6960
  174.       TabIndex        =   6
  175.       Text            =   "0.1570"
  176.       Top             =   5400
  177.       Width           =   855
  178.    End
  179.    Begin VB.TextBox ThetaText 
  180.       Height          =   285
  181.       Left            =   5640
  182.       TabIndex        =   4
  183.       Text            =   "0.6283"
  184.       Top             =   5400
  185.       Width           =   855
  186.    End
  187.    Begin VB.TextBox RText 
  188.       Height          =   285
  189.       Left            =   4080
  190.       TabIndex        =   2
  191.       Text            =   "10"
  192.       Top             =   5400
  193.       Width           =   855
  194.    End
  195.    Begin VB.PictureBox Pict 
  196.       AutoRedraw      =   -1  'True
  197.       Height          =   5295
  198.       Left            =   2400
  199.       ScaleHeight     =   349
  200.       ScaleMode       =   3  'Pixel
  201.       ScaleWidth      =   357
  202.       TabIndex        =   0
  203.       Top             =   0
  204.       Width           =   5415
  205.    End
  206.    Begin MSComDlg.CommonDialog LoadDialog 
  207.       Left            =   1680
  208.       Top             =   5040
  209.       _version        =   65536
  210.       _extentx        =   847
  211.       _extenty        =   847
  212.       _stockprops     =   0
  213.       cancelerror     =   -1  'True
  214.    End
  215.    Begin VB.Label Label1 
  216.       Caption         =   "Phi"
  217.       Height          =   255
  218.       Index           =   2
  219.       Left            =   6600
  220.       TabIndex        =   5
  221.       Top             =   5415
  222.       Width           =   375
  223.    End
  224.    Begin VB.Label Label1 
  225.       Caption         =   "Theta"
  226.       Height          =   255
  227.       Index           =   1
  228.       Left            =   5040
  229.       TabIndex        =   3
  230.       Top             =   5415
  231.       Width           =   495
  232.    End
  233.    Begin VB.Label Label1 
  234.       Caption         =   "R"
  235.       Height          =   255
  236.       Index           =   0
  237.       Left            =   3840
  238.       TabIndex        =   1
  239.       Top             =   5415
  240.       Width           =   255
  241.    End
  242.    Begin VB.Menu mnuFile 
  243.       Caption         =   "&File"
  244.       Begin VB.Menu mnuFileLoad 
  245.          Caption         =   "&Load..."
  246.          Shortcut        =   ^L
  247.       End
  248.       Begin VB.Menu mnuFileSaveAs 
  249.          Caption         =   "&Save As..."
  250.          Shortcut        =   ^A
  251.       End
  252.       Begin VB.Menu mnuFileSep 
  253.          Caption         =   "-"
  254.       End
  255.       Begin VB.Menu mnuFileExit 
  256.          Caption         =   "E&xit"
  257.       End
  258.    End
  259. Attribute VB_Name = "ExtrudeForm"
  260. Attribute VB_Creatable = False
  261. Attribute VB_Exposed = False
  262. Option Explicit
  263. ' Location of viewing eye.
  264. Dim EyeR As Single
  265. Dim EyeTheta As Single
  266. Dim EyePhi As Single
  267. Const dtheta = PI / 20
  268. Const Dphi = PI / 20
  269. Const Dr = 1
  270. ' Location of focus point.
  271. Const FocusX = 0#
  272. Const FocusY = 0#
  273. Const FocusZ = 0#
  274. Dim Projector(1 To 4, 1 To 4) As Single
  275. Dim CurveNum As Integer
  276. Dim PathNum As Integer
  277. Dim ThePicture As ObjPicture
  278. Dim TheExtrusion As ObjExtrusion
  279. Dim ShowingParameters As Boolean
  280. ' ************************************************
  281. ' Create the selected path.
  282. ' ************************************************
  283. Sub CreatePath()
  284. Dim y As Single
  285. Dim R As Single
  286. Dim dtheta As Single
  287. Dim theta As Single
  288.     Select Case PathNum
  289.         Case 0  ' Vertical line.
  290.             For y = 0 To 4 Step 0.5
  291.                 TheExtrusion.AddPathPoint 0, y, 0
  292.             Next y
  293.         Case 1  ' Angled line.
  294.             For y = 0 To 4 Step 0.5
  295.                 TheExtrusion.AddPathPoint y / 2, y, y / 2
  296.             Next y
  297.         
  298.         Case 2  ' Wavy line.
  299.             R = 2
  300.             dtheta = PI / 5
  301.             TheExtrusion.AddPathPoint 0, 0, 0
  302.             For theta = dtheta To 2 * PI Step dtheta
  303.                 TheExtrusion.AddPathPoint _
  304.                     R * Sin(theta), theta * 0.7, 0
  305.             Next theta
  306.         
  307.         Case 3  ' Helix.
  308.             R = 2
  309.             dtheta = PI / 10
  310.             TheExtrusion.AddPathPoint R, 0, 0
  311.             For theta = dtheta To 2 * PI Step dtheta
  312.                 TheExtrusion.AddPathPoint _
  313.                     R * Cos(theta), _
  314.                     theta * 0.8, _
  315.                     R * Sin(theta)
  316.             Next theta
  317.             
  318.         Case 4  ' Semicircle.
  319.             R = 2
  320.             dtheta = PI / 10
  321.             TheExtrusion.AddPathPoint 0, 0, 0
  322.             For theta = dtheta To PI Step dtheta
  323.                 TheExtrusion.AddPathPoint _
  324.                     R * Sin(theta), _
  325.                     R * (1 - Cos(theta)), _
  326.                     0
  327.             Next theta
  328.         
  329.         Case 5  ' Circle.
  330.             R = 2
  331.             dtheta = PI / 10
  332.             TheExtrusion.AddPathPoint 0, 0, 0
  333.             For theta = dtheta To 2 * PI - dtheta + 0.01 Step dtheta
  334.                 TheExtrusion.AddPathPoint _
  335.                     R * Sin(theta), _
  336.                     R * (1 - Cos(theta)), _
  337.                     0
  338.             Next theta
  339.             TheExtrusion.AddPathPoint 0, 0, 0
  340.     End Select
  341. End Sub
  342. ' ************************************************
  343. ' Create the selected curve.
  344. ' ************************************************
  345. Sub CreateCurve()
  346. Dim R As Single
  347. Dim dtheta As Single
  348. Dim theta As Single
  349.     Select Case CurveNum
  350.         Case 0  ' Square.
  351.             TheExtrusion.AddCurvePoint -2, 0, -2
  352.             TheExtrusion.AddCurvePoint -2, 0, 2
  353.             TheExtrusion.AddCurvePoint 2, 0, 2
  354.             TheExtrusion.AddCurvePoint 2, 0, -2
  355.             TheExtrusion.AddCurvePoint -2, 0, -2
  356.         Case 1  ' Rectangle.
  357.             TheExtrusion.AddCurvePoint -0.5, 0, -2
  358.             TheExtrusion.AddCurvePoint -0.5, 0, 2
  359.             TheExtrusion.AddCurvePoint 0.5, 0, 2
  360.             TheExtrusion.AddCurvePoint 0.5, 0, -2
  361.             TheExtrusion.AddCurvePoint -0.5, 0, -2
  362.         
  363.         Case 2  ' Semicircle.
  364.             R = 2
  365.             dtheta = PI / 10
  366.             TheExtrusion.AddCurvePoint R, 0, 0
  367.             For theta = dtheta To PI Step dtheta
  368.                 TheExtrusion.AddCurvePoint _
  369.                     R * Cos(theta), 0, R * Sin(theta)
  370.             Next theta
  371.             
  372.         Case 3, 4   ' Circle, small circle.
  373.             If CurveNum = 3 Then
  374.                 R = 2
  375.                 dtheta = PI / 10
  376.             Else
  377.                 R = 0.5
  378.                 dtheta = PI / 4
  379.             End If
  380.             TheExtrusion.AddCurvePoint R, 0, 0
  381.             For theta = dtheta To 2 * PI - dtheta + 0.1 Step dtheta
  382.                 TheExtrusion.AddCurvePoint _
  383.                     R * Cos(theta), 0, R * Sin(theta)
  384.             Next theta
  385.             TheExtrusion.AddCurvePoint R, 0, 0
  386.             
  387.         Case 5  ' Sine wave.
  388.             R = 2
  389.             dtheta = PI / 10
  390.             theta = -PI / 2
  391.             TheExtrusion.AddCurvePoint _
  392.                 R * Sin(theta), 0, 2 * theta
  393.             For theta = -PI / 2 + dtheta To PI / 2 Step dtheta
  394.                 TheExtrusion.AddCurvePoint _
  395.                     R * Sin(theta), 0, 2 * theta
  396.             Next theta
  397.             
  398.     End Select
  399. End Sub
  400. Sub WaitEnd()
  401.     MousePointer = vbDefault
  402. End Sub
  403. Sub WaitStart()
  404.     MousePointer = vbHourglass
  405.     DoEvents
  406. End Sub
  407. ' ************************************************
  408. ' Create the extruded data and display it.
  409. ' ************************************************
  410. Private Sub CmdExtrude_Click()
  411. Dim pline As ObjPolyline
  412.     ' If we currently have an APF file loaded,
  413.     ' restore default settings.
  414.     If CurveNum > 5 Then
  415.         CurveChoice(0).value = True
  416.         PathChoice(0).value = True
  417.     End If
  418.     WaitStart
  419.     Set ThePicture = New ObjPicture
  420.     Set TheExtrusion = New ObjExtrusion
  421.     ThePicture.objects.Add TheExtrusion
  422.     CreateCurve
  423.     CreatePath
  424.     TheExtrusion.Extrude
  425.     If ShowAxesCheck.value = vbChecked Then
  426.         Set pline = New ObjPolyline
  427.         ThePicture.objects.Add pline
  428.         pline.AddSegment 0, 0, 0, 5, 0, 0
  429.         pline.AddSegment 0, 0, 0, 0, 5, 0
  430.         pline.AddSegment 0, 0, 0, 0, 0, 5
  431.     End If
  432.     DrawData Pict
  433.     Pict.SetFocus
  434. End Sub
  435. Private Sub CurveChoice_Click(Index As Integer)
  436.     CurveNum = Index
  437.     Pict.SetFocus
  438. End Sub
  439. ' *******************************************************
  440. ' Rotate the points in the cube and draw the cube.
  441. ' *******************************************************
  442. Private Sub DrawData(pic As Object)
  443. Dim x As Single
  444. Dim y As Single
  445. Dim z As Single
  446. Dim S(1 To 4, 1 To 4) As Single
  447. Dim t(1 To 4, 1 To 4) As Single
  448. Dim ST(1 To 4, 1 To 4) As Single
  449. Dim PST(1 To 4, 1 To 4) As Single
  450.     MousePointer = vbHourglass
  451.     Refresh
  452.     ' Prevent overflow errors when drawing lines
  453.     ' too far out of bounds.
  454.     On Error Resume Next
  455.     ' Scale and translate so it looks OK in pixels.
  456.     m3Scale S, 35, -35, 1
  457.     m3Translate t, 180, 250, 0
  458.     m3MatMultiplyFull ST, S, t
  459.     m3MatMultiplyFull PST, Projector, ST
  460.     ' Transform the points.
  461.     ThePicture.ApplyFull PST
  462.     ' Display the data.
  463.     pic.Cls
  464.     ThePicture.Draw pic, EyeR
  465.     pic.Refresh
  466.     ' Display the viewnig parameters.
  467.     ShowViewingParameters
  468.     MousePointer = vbDefault
  469. End Sub
  470. Sub ShowViewingParameters()
  471.     ShowingParameters = True
  472.     RText.Text = Format$(EyeR, "0.0000")
  473.     ThetaText.Text = Format$(EyeTheta, "0.0000")
  474.     PhiText.Text = Format$(EyePhi, "0.0000")
  475.     RText.Refresh
  476.     ThetaText.Refresh
  477.     PhiText.Refresh
  478.     ShowingParameters = False
  479. End Sub
  480. Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  481.     Select Case KeyCode
  482.         Case vbKeyLeft
  483.             EyeTheta = EyeTheta - dtheta
  484.         
  485.         Case vbKeyRight
  486.             EyeTheta = EyeTheta + dtheta
  487.         
  488.         Case vbKeyUp
  489.             EyePhi = EyePhi - Dphi
  490.         
  491.         Case vbKeyDown
  492.             EyePhi = EyePhi + Dphi
  493.                 
  494.         Case Else
  495.             Exit Sub
  496.     End Select
  497.     m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
  498.     DrawData Pict
  499. End Sub
  500. Private Sub Form_KeyPress(KeyAscii As Integer)
  501.     Select Case KeyAscii
  502.         Case Asc("+")
  503.             EyeR = EyeR + Dr
  504.         
  505.         Case Asc("-")
  506.             EyeR = EyeR - Dr
  507.         
  508.         Case Else
  509.             Exit Sub
  510.     End Select
  511.     m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
  512.     DrawData Pict
  513. End Sub
  514. Private Sub Form_Load()
  515.     ' Initialize the eye position.
  516.     EyeR = 10
  517.     EyeTheta = PI * 0.2
  518.     EyePhi = PI * 0.1
  519.     ' Initialize the projection transformation.
  520.     m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
  521. End Sub
  522. Private Sub mnuFileExit_Click()
  523.     Unload Me
  524. End Sub
  525. Private Sub mnuFileLoad_Click()
  526. Dim fname As String
  527. Dim filenum As Integer
  528. Dim txt As String
  529. Dim Xmin As Single
  530. Dim ymin As Single
  531. Dim xmax As Single
  532. Dim ymax As Single
  533.     ' Allow the user to pick a file.
  534.     On Error Resume Next
  535.     LoadDialog.filename = "*.APF"
  536.     LoadDialog.ShowOpen
  537.     If Err.Number = cdlCancel Then
  538.         Unload LoadDialog
  539.         Exit Sub
  540.     ElseIf Err.Number <> 0 Then
  541.         Unload LoadDialog
  542.         Beep
  543.         MsgBox "Error selecting file.", , vbExclamation
  544.         Exit Sub
  545.     End If
  546.     On Error GoTo 0
  547.     fname = LoadDialog.filename
  548.     LoadDialog.InitDir = Left$(fname, Len(fname) _
  549.         - Len(LoadDialog.FileTitle) - 1)
  550.     ' Clear the picture.
  551.     Set ThePicture = Nothing
  552.     ' Open the file.
  553.     filenum = FreeFile
  554.     Open fname For Input As #filenum
  555.     ' Make sure it's an Object Picture File.
  556.     Input #filenum, txt
  557.     If txt <> "3D APF PICTURE" Then
  558.         Close filenum
  559.         Beep
  560.         MsgBox "Error reading file """ & fname & """.", , vbExclamation
  561.         Exit Sub
  562.     End If
  563.     ' Read the picture.
  564.     MousePointer = vbHourglass
  565.     DoEvents
  566.     Set ThePicture = New ObjPicture
  567.     ThePicture.FileInput filenum
  568.     ' Close the file.
  569.     Close filenum
  570.     ' Refresh the display.
  571.     DrawData Pict
  572.     ' Deselect all the option buttons.
  573.     For CurveNum = 0 To 5
  574.         If CurveChoice(CurveNum).value Then _
  575.             CurveChoice(CurveNum).value = False
  576.     Next CurveNum
  577.     For PathNum = 0 To 5
  578.         If PathChoice(PathNum).value Then _
  579.             PathChoice(PathNum).value = False
  580.     Next PathNum
  581.     MousePointer = vbDefault
  582. End Sub
  583. Private Sub mnuFileSaveAs_Click()
  584. Dim fname As String
  585. Dim filenum As Integer
  586.     ' Allow the user to pick a file.
  587.     On Error Resume Next
  588.     LoadDialog.filename = "*.APF"
  589.     LoadDialog.Flags = cdlOFNOverwritePrompt + cdlOFNHideReadOnly
  590.     LoadDialog.ShowSave
  591.     If Err.Number = cdlCancel Then
  592.         Unload LoadDialog
  593.         Exit Sub
  594.     ElseIf Err.Number <> 0 Then
  595.         Unload LoadDialog
  596.         Beep
  597.         MsgBox "Error selecting file.", , vbExclamation
  598.         Exit Sub
  599.     End If
  600.     On Error GoTo 0
  601.     fname = LoadDialog.filename
  602.     LoadDialog.InitDir = Left$(fname, Len(fname) _
  603.         - Len(LoadDialog.FileTitle) - 1)
  604.     ' Open the file.
  605.     filenum = FreeFile
  606.     Open fname For Output As #filenum
  607.     ' Write the picture.
  608.     ThePicture.FileWrite filenum
  609.     ' Close the file.
  610.     Close filenum
  611. End Sub
  612. Private Sub PathChoice_Click(Index As Integer)
  613.     PathNum = Index
  614.     Pict.SetFocus
  615. End Sub
  616. Private Sub PhiText_Change()
  617.     If ShowingParameters Then Exit Sub
  618.     EyePhi = CSng(PhiText.Text)
  619.     m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
  620.     DrawData Pict
  621. End Sub
  622. Private Sub RText_Change()
  623.     If ShowingParameters Then Exit Sub
  624.     EyeR = CSng(RText.Text)
  625.     m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
  626.     DrawData Pict
  627. End Sub
  628. Private Sub ShowAxesCheck_Click()
  629.     CmdExtrude_Click
  630.     Pict.SetFocus
  631. End Sub
  632. Private Sub ThetaText_Change()
  633.     If ShowingParameters Then Exit Sub
  634.     EyeTheta = CSng(ThetaText.Text)
  635.     m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
  636.     DrawData Pict
  637. End Sub
  638.